Attribute VB_Name = "MODexport"
Option Explicit

Private _
    oConn As ADODB.Connection, _
    oRS As ADODB.Recordset, _
    fso As Scripting.FileSystemObject, _
    oTextFile As Scripting.TextStream
    
Dim _
    sTableToExport As String, _
    sFieldsToExport As String, _
    sExportPath As String

Dim i As Long

' Export to Excel by creating a new workbook and worksheets, then show the Application to the user and save it --------------------------

Public Function exportToExcel(sTableToExport As String, sFieldsToExport As String, sExportPath As String) As Boolean
    
    On Error Resume Next

    Dim _
        oExcel As Excel.Application, _
        oWorkbook As Excel.Workbook, _
        oWorkSheet As Excel.Worksheet

    Dim _
        iTotalWorkSheets As Integer, _
        iWorkSheetsToAdd As Integer
    
    DLGexport.MousePointer = vbHourglass
    FRMmain.MousePointer = vbHourglass
    DLGexport.CMDExport.Enabled = False

    If Not openRecordset(sTableToExport, sFieldsToExport) Then
    
        Exit Function
    
    End If
    
    DLGexport.ProgressBar.Visible = True

    DLGexport.ProgressBar.Value = 33

    ' Create a new Excel object ---------------------------------------------------------------------------------------------

    Set oExcel = New Excel.Application
    
    DoEvents
    
    If Err.Number <> 0 Then
    
        logMessage _
            1, _
            "MODexport", _
            "Could not create new Excel application", _
            , _
            Err.Number, _
            Err.Description
    
        MsgBox _
            "Could not export" & vbCrLf & _
            "Reason : Could not create new Excel application"
        
        GoTo exitSub
        
    Else
    
        logMessage _
            5, _
            "MODexport", _
            "Created Excel application object"
    
    End If
    
    Set oWorkbook = oExcel.Workbooks.Add
    
    DoEvents
    
    If Err.Number <> 0 Then
    
        logMessage _
            1, _
            "MODexport", _
            "Could not add workbook", _
            , _
            Err.Number, _
            Err.Description
    
        MsgBox _
            "Could not export" & vbCrLf & _
            "Reason : Could not add workbook"
        
        GoTo exitSub
    
    Else
    
        logMessage _
            4, _
            "MODexport", _
            "Added workbook to Excel file"
    
    End If
    
    iTotalWorkSheets = Int(oRS.RecordCount / 65000) + 1
    
    On Error Resume Next
    
    If oWorkbook.Worksheets.Count < iTotalWorkSheets Then
    
        iWorkSheetsToAdd = iTotalWorkSheets - oWorkbook.Worksheets.Count
    
        oWorkbook.Worksheets.Add , , iWorkSheetsToAdd
        
        DoEvents
        
        If Err.Number <> 0 Then
    
            logMessage _
                1, _
                "MODexport", _
                "Could not add worksheet", _
                , _
                Err.Number, _
                Err.Description
        
            MsgBox _
                "Could not export" & vbCrLf & _
                "Reason : Could not add worksheet"
            
            GoTo exitSub
            
        Else
        
            logMessage _
                4, _
                "MODexport", _
                "Added worksheet to Excel file", _
                "Worksheets added = " & iWorkSheetsToAdd
        
        End If
    
    End If
    
    For i = 1 To iTotalWorkSheets
     
    
        Dim j As Integer
    
        DLGexport.ProgressBar.Value = i / iTotalWorkSheets * 100
    
        Set oWorkSheet = oWorkbook.Worksheets(i)
    
        For j = 1 To oRS.Fields.Count
    
             oWorkSheet.Cells(1, j).Value = oRS.Fields(j - 1).Name
    
            DoEvents
    
        Next
        
        DoEvents
        
        oWorkSheet.Cells(2, 1).CopyFromRecordset oRS, 65000
        
        DoEvents
        
        If Err.Number <> 0 Then
    
            logMessage _
                1, _
                "MODexport", _
                "Could not copy from recordset", _
                , _
                Err.Number, _
                Err.Description
        
            MsgBox _
                "Could not export" & vbCrLf & _
                "Reason : Could not copy from recordset"
            
            GoTo exitSub
            
        Else
        
            logMessage _
                4, _
                "MODexport", _
                "Copied records from recordset to Excel"
                
        End If
        
        oWorkSheet.Name = sTableToExport & "_" & i
        
    Next
    
    ' Make Excel visible -------------------------------------------------------------------------------------------------------------------
    
    'oExcel.Visible = True
    'oExcel.UserControl = True

    ' Save the Workbook -------------------------------------------------------------------------------------------------------------
    
    On Error Resume Next
    
    DoEvents
    
    oWorkbook.SaveAs sExportPath
    
    DoEvents
    
    If Err.Number <> 0 Then
    
        logMessage _
            1, _
            "MODexport", _
            "Could not save Excel file", _
            "Path = " & sExportPath, _
            Err.Number, _
            Err.Description
    
        MsgBox "Could not save Excel file"
    
        GoTo exitSub
        
    Else
    
        logMessage _
            3, _
            "MODexport", _
            "Saved Excel file", _
            "Path = " & sExportPath
            
    End If
    
    exportToExcel = True
    
    MsgBox "Finished exporting"

exitSub:
    
    DLGexport.MousePointer = vbArrow
    FRMmain.MousePointer = vbArrow
    
    oRS.Close
    oConn.Close
    
    Set oRS = Nothing
    Set oConn = Nothing
    
    oExcel.Quit
    
    Set oExcel = Nothing
    Set oWorkbook = Nothing
    Set oWorkSheet = Nothing
    
End Function

' Export records to a text file -----------------------------------------------------------------------------------------------------

Public Function exportToText(sTableToExport As String, sFieldsToExport As String, sExportPath As String)

    On Error Resume Next

    Dim _
        sLine As String, _
        sFieldValue As String
    
    Dim lTotalRecords As Long

    Dim oField As Field

    DLGexport.ProgressBar.Visible = True
    DLGexport.CMDExport.Enabled = False
    DLGexport.CMDcancel.Enabled = False
    FRMmain.MousePointer = vbHourglass
    DLGexport.MousePointer = vbHourglass

    If Not openRecordset(sTableToExport, sFieldsToExport) Then
    
        GoTo exitFunction
        
    End If
    
    On Error Resume Next
    
    Set fso = New Scripting.FileSystemObject
    
    If Err.Number <> 0 Then
    
        logMessage _
            1, _
            "MODexport", _
            "Could not create FileSystem object for exporting to text file", _
            , _
            Err.Number, _
            Err.Description
            
        GoTo exitFunction
            
    Else
    
        logMessage _
            5, _
            "MODexport", _
            "Created FileSystem object for exporting to text file"
    
    End If
    
    
    If fso.FileExists(sExportPath) Then
    
        If MsgBox( _
            "A file with the name """ & sExportPath & """ already exists" & _
            vbCrLf & _
            "Would you like to replace it ?", vbOKCancel) <> 1 Then
            
            GoTo exitFunction
            
        End If
    
    End If
    
    Set oTextFile = fso.CreateTextFile(sExportPath, True)
    
    If Err.Number <> 0 Then
    
        logMessage _
            1, _
            "MODexport", _
            "Could not create text file object for exporting to text file", _
            , _
            Err.Number, _
            Err.Description
            
        Set fso = Nothing
        
        GoTo exitFunction
            
    Else
    
        logMessage _
            5, _
            "MODexport", _
            "Created text file for exporting to text file"
    
    End If
    
    For Each oField In oRS.Fields
    
        sLine = sLine & oField.Name & vbTab
    
    Next
    
    oTextFile.WriteLine sLine
    
    sLine = ""
    
    i = 0

    lTotalRecords = oRS.RecordCount
    
    ' Loop through records and write to file ----------------------------------------------------------------------------------------

    Do Until oRS.EOF
    
        sLine = ""
    
        For Each oField In oRS.Fields
        
            sFieldValue = oField.Value
                 
            ' replace commas, because they are used to seperate the fields ------------------------------------------------------------
         
            If sFieldValue <> "" Then
            
                sFieldValue = Replace(sFieldValue, ",", "", 1, , vbTextCompare)
        
            End If
            
            sLine = sLine & sFieldValue & ","
        
        Next
        
        ' remove the last comma ----------------------------------------------------------------------------------------------------
        
        sLine = Left(sLine, Len(sLine) - 1)
        
        On Error Resume Next
    
        oTextFile.WriteLine sLine
    
        If Err.Number <> 0 Then
        
            logMessage _
                2, _
                "MODexport", _
                "Could not write line to text file", _
                "Line = " & sLine, _
                Err.Number, _
                Err.Description
        
            Err.Clear
        
        End If
        
        DoEvents
    
        i = i + 1
         
        DLGexport.ProgressBar.Value = i / lTotalRecords * 100
        
        oRS.MoveNext
    
    Loop
    
    oTextFile.Close
    
    Set oTextFile = Nothing
    Set fso = Nothing

    MsgBox "Finished exporting"
    
    Unload DLGexport
    
exitFunction:

    DLGexport.CMDExport.Enabled = True
    DLGexport.CMDcancel.Enabled = True
    FRMmain.MousePointer = vbArrow
    DLGexport.MousePointer = vbArrow

End Function

' Create a connectioon and open a recordet --------------------------------------------------------------------------------------

Private Function openRecordset(sTableToExport As String, sFieldsToExport As String) As Boolean

    On Error Resume Next

    Dim sRSOpen As String

    Set oConn = New ADODB.Connection
    
    If Err.Number <> 0 Then
    
        logMessage _
            1, _
            "MODexport", _
            "Could not create ADODB connection object", _
            , _
            Err.Number, _
            Err.Description
    
        MsgBox _
            "Could not export" & vbCrLf & _
            "Reason : Could not create connection to database"
        
        Exit Function
        
    Else
    
        logMessage _
            5, _
            "MODexport", _
            "Created new ADODB connection object"
    
    End If
    
    Set oRS = New ADODB.Recordset

    If Err.Number <> 0 Then
    
        logMessage _
            1, _
            "MODexport", _
            "Could not create ADODB recordset object", _
            , _
            Err.Number, _
            Err.Description
    
        MsgBox _
            "Could not export" & vbCrLf & _
            "Reason : Could not create connection to database recordset"
        
        Exit Function
    
    Else
    
        logMessage _
            5, _
            "MODexport", _
            "Created ADODB recordset object"
    
    End If

    Dim sConnection As String
    
    sConnection = FRMmain.Adodc1.ConnectionString

    oConn.Open sConnection
    
    If Err.Number <> 0 Then
    
        logMessage _
            1, _
            "MODexport", _
            "Could not open ADODB connection", _
            "Connection string = " & sConnection, _
            Err.Number, _
            Err.Description
    
        MsgBox _
            "Could not export" & vbCrLf & _
            "Reason : Could not open connection to database"
        
        Exit Function
    
    Else
    
        logMessage _
            4, _
            "MODexport", _
            "Opened ADODB connection", _
            "Connection string = " & sConnection
    
    End If

    sRSOpen = "SELECT " & sFieldsToExport & " FROM " & sTableToExport & " ORDER BY [uniqueID]"
    
    On Error Resume Next
    
    oRS.Open sRSOpen, oConn, 1, 3
    
    If Err.Number <> 0 Then
    
        logMessage _
            1, _
            "MODexport", _
            "Could not open ADODB recordset", _
            "Recordset open string = " & sRSOpen, _
            Err.Number, _
            Err.Description
    
        MsgBox _
            "Could not export" & vbCrLf & _
            "Reason : Could not open recordset"
        
        Exit Function
        
    Else
    
        logMessage _
            4, _
            "MODexport", _
            "Opened ADODB recordset", _
            "Recordset open string = " & sRSOpen
    
    End If

    openRecordset = True

End Function


'Public Function export(tableToExport As String, strFieldsToExport As String, strExportAs As String, strExportMethod As String)
'
'    On Error Resume Next
'
'    FRMmain.MousePointer = 11
'    DLGexport.MousePointer = 11
'
'    Dim conn As ADODB.Connection
'    Dim r As ADODB.Recordset
'    Dim openStr As String
'    Dim strConn As String
'
'    Set conn = New ADODB.Connection
'    Set r = New ADODB.Recordset
'    Set fso = New Scripting.FileSystemObject
'
'    strConn = "PROVIDER=MICROSOFT.JET.OLEDB.4.0;DATA SOURCE=" & theFileName
'    conn.Open strConn
'
'    openStr = "SELECT " & strFieldsToExport & " FROM " & tableToExport
'    r.Open openStr, conn, 1, 3
'
'    Dim longFileRow As Long
'    Dim intFileNumber As Integer
'    Dim intNumberOfFiles As Integer
'    Dim longNumberOfRecords As Long
'    Dim strHeader As String
'    Dim strLine As String
'    intFileNumber = 1
'    longNumberOfRecords = r.RecordCount
'    intNumberOfFiles = Int(r.RecordCount / 65000) + 1
'
'    If strExportMethod = "excel" Then
''-------------------------------------------------------------------'
''   Export to Excel                                                 '
''-------------------------------------------------------------------'
'        For i = 1 To intNumberOfFiles
'            strExportAs = Replace(strExportAs, ".xls", "", , , vbTextCompare)
'            Set excelFile = fso.CreateTextFile(App.Path & "/" & strExportAs & intFileNumber & ".xls", True, True)
'            header = ""
'            For Each fld In r.Fields
'                header = header & fld.Name & Chr(9)
'            Next
'            excelFile.WriteLine header
'            Do While longFileRow < 65001 And Not r.EOF
'                strLine = ""
'                For Each fld In r.Fields
'                    strLine = strLine & fld.Value & Chr(9)
'                Next
'                excelFile.WriteLine strLine
'                longFileRow = longFileRow + 1
'                r.MoveNext
'            Loop
'            longFileRow = 0
'            excelFile.Close
'            Set excelFile = Nothing
'            intFileNumber = intFileNumber + 1
'        Next
'    Else
''-------------------------------------------------------------------'
''   Export to Text File                                             '
''-------------------------------------------------------------------'
'        intNumberOfFiles = 1
'        Dim textFile As Object
'        Set textFile = fso.CreateTextFile(App.Path & "/" & strExportAs, True, True)
'        Dim line As String
'        For Each fld In r.Fields
'            header = header & fld.Name & Chr(9)
'        Next
'            textFile.WriteLine header
'        Do Until r.EOF
'            line = ""
'            For Each fld In r.Fields
'                Dim fieldVal
'                If fld.Value <> "" And InStr(fld.Value, ",") <> 0 Then
'                    fieldVal = Replace(fld.Value, ",", "", , , vbTextCompare)
'                Else
'                    fieldVal = fld.Value
'                End If
'                line = line & fieldVal & ","
'            Next
'            textFile.WriteLine line
'            r.MoveNext
'        Loop
'        textFile.Close
'        Set textFile = Nothing
'        Set fso = Nothing
'    End If
'doStop:
'    r.Close
'    conn.Close
'
'    Set r = Nothing
'    Set conn = Nothing
'
'    Set fs = Nothing
'    Set excelFile = Nothing
'    FRMmain.MousePointer = 0
'    DLGexport.MousePointer = 0
'    MsgBox "Finished Exporting " & intNumberOfFiles & " Files"
'End Function
